perm filename INVER2.LSP[W78,JMC] blob
sn#341531 filedate 1978-03-19 generic text, type T, neo UTF8
(DEFUN INVERT (PAT EXP ALISTS)
(COND ((OR (NULL PAT) (EQ PAT T) (NUMBERP PAT))
(COND ((EQUAL PAT EXP) ALISTS) (T NIL)))
((ATOM PAT)
(MAPAPPEND (FUNCTION (LAMBDA (ALIST) ((LAMBDA (Z)
(COND ((NULL Z)
(LIST
(CONS
(CONS
PAT
EXP)
ALIST)))
((EQUAL
(CDR Z)
EXP)
(LIST
ALIST))
(T NIL)))
(ASSOC PAT
ALIST))))
ALISTS))
((EQ (CAR PAT) 'QUOTE)
(COND ((EQUAL (CADR PAT) EXP) ALISTS) (T NIL)))
((EQ (CAR PAT) 'CONS)
(COND ((ATOM EXP) NIL)
(T (INVERT (CADDR PAT)
(CDR EXP)
(INVERT (CADR PAT)
(CAR EXP)
ALISTS)))))
((EQ (CAR PAT) 'LIST)
(INVERT (COND ((NULL (CDR PAT)) 'NIL)
(T (LIST 'CONS
(CADR PAT)
(CONS 'LIST (CDDR PAT)))))
EXP
ALISTS))
((EQ (CAR PAT) 'APPEND)
(MAPAPPEND (FUNCTION (LAMBDA (Z)
(INVERT (CONS 'LIST
(CDR PAT))
Z
ALISTS)))
(SEGMENTS EXP (LENGTH (CDR PAT)))))))
(DEFUN MAPAPPEND (F U)
(COND ((NULL U) NIL)
(T (APPEND (F (CAR U)) (MAPAPPEND F (CDR U))))))
(DEFUN SPLIT (U)
(CONS (LIST NIL U)
(COND ((NULL U) NIL)
(T (MAPCAR (FUNCTION (LAMBDA (Z)
(CONS (CONS (CAR U)
(CAR Z))
(CDR Z))))
(SPLIT (CDR U)))))))
(DEFUN SEGMENTS (U N)
(COND
((EQUAL N 1.) (LIST (LIST U)))
(T
(MAPAPPEND
(FUNCTION
(LAMBDA (W) (MAPCAR (FUNCTION (LAMBDA (Z)
(APPEND Z (CDR W))))
(SPLIT (CAR W)))))
(SEGMENTS U (SUB1 N))))))